home *** CD-ROM | disk | FTP | other *** search
/ Chip 2000 November / Chip Kasım 2000.iso / prog / share / 11 / setup.exe / %MAINDIR% / DEMOS / CIHTTP / HTTPEXP / servers / mapserve.frm (.txt) < prev    next >
Encoding:
Visual Basic Form  |  2000-09-07  |  10.5 KB  |  293 lines
  1. VERSION 5.00
  2. Begin VB.Form MapServers 
  3.    BorderStyle     =   4  'Fixed ToolWindow
  4.    Caption         =   "Map HTTP Server"
  5.    ClientHeight    =   1740
  6.    ClientLeft      =   1815
  7.    ClientTop       =   2160
  8.    ClientWidth     =   5835
  9.    Icon            =   "MapServe.frx":0000
  10.    LinkTopic       =   "Form1"
  11.    LockControls    =   -1  'True
  12.    MaxButton       =   0   'False
  13.    MinButton       =   0   'False
  14.    PaletteMode     =   1  'UseZOrder
  15.    ScaleHeight     =   1740
  16.    ScaleWidth      =   5835
  17.    ShowInTaskbar   =   0   'False
  18.    Begin VB.CheckBox chkReconnect 
  19.       Caption         =   "Reconnec&t at logon"
  20.       Height          =   240
  21.       Left            =   960
  22.       TabIndex        =   5
  23.       Top             =   1155
  24.       Width           =   3090
  25.    End
  26.    Begin VB.CommandButton cmdAdd 
  27.       Caption         =   "&Add"
  28.       Height          =   345
  29.       Left            =   135
  30.       TabIndex        =   2
  31.       Top             =   630
  32.       Width           =   1290
  33.    End
  34.    Begin VB.CommandButton cmdRemove 
  35.       Caption         =   "&Remove"
  36.       Enabled         =   0   'False
  37.       Height          =   345
  38.       Left            =   1470
  39.       TabIndex        =   3
  40.       Top             =   630
  41.       Width           =   1290
  42.    End
  43.    Begin VB.CommandButton cmdProperties 
  44.       Caption         =   "&Properties"
  45.       Enabled         =   0   'False
  46.       Height          =   345
  47.       Left            =   2805
  48.       TabIndex        =   4
  49.       Top             =   630
  50.       Width           =   1290
  51.    End
  52.    Begin VB.ComboBox cmbServers 
  53.       Height          =   315
  54.       Left            =   960
  55.       Style           =   2  'Dropdown List
  56.       TabIndex        =   1
  57.       Top             =   180
  58.       Width           =   3135
  59.    End
  60.    Begin VB.CommandButton cmdCancel 
  61.       Cancel          =   -1  'True
  62.       Caption         =   "Cancel"
  63.       Height          =   345
  64.       Left            =   4515
  65.       TabIndex        =   7
  66.       Top             =   630
  67.       Width           =   1125
  68.    End
  69.    Begin VB.CommandButton cmdOK 
  70.       Caption         =   "OK"
  71.       Default         =   -1  'True
  72.       Enabled         =   0   'False
  73.       Height          =   345
  74.       Left            =   4515
  75.       TabIndex        =   6
  76.       Top             =   180
  77.       Width           =   1125
  78.    End
  79.    Begin VB.Label lblGeneric 
  80.       Caption         =   "&Server:"
  81.       Height          =   195
  82.       Index           =   0
  83.       Left            =   180
  84.       TabIndex        =   0
  85.       Top             =   240
  86.       Width           =   675
  87.    End
  88. Attribute VB_Name = "MapServers"
  89. Attribute VB_GlobalNameSpace = False
  90. Attribute VB_Creatable = False
  91. Attribute VB_PredeclaredId = True
  92. Attribute VB_Exposed = False
  93. Option Explicit
  94. '<Public>--------------------------------------------
  95. Public Servers          As Collection
  96. Public ThisExplorer     As Form
  97. Public ThisServer       As HTTPServer
  98. Public PressedOK        As Boolean
  99. '</Public>-------------------------------------------
  100. '<Private>------------------------------------------
  101. Private NumberServers   As Integer
  102. '</Private>-----------------------------------------
  103. Private Sub cmbServers_Click()
  104.     cmdRemove.Enabled = True
  105.     cmdProperties.Enabled = True
  106.     cmdOK.Enabled = True
  107.     cmdOK.Default = True
  108.     On Error Resume Next '---- possible after remove
  109.     chkReconnect.Value = GetServer(cmbServers.List(cmbServers.ListIndex)).Reconnect
  110.     On Error GoTo 0
  111. End Sub
  112. Private Sub cmdAdd_Click()
  113.     With Server
  114.         .Mode = ciAdd
  115.         .MyCaption = "Add HTTP Server"
  116.         .Show vbModal
  117.         If (Not .PressedOK) Then Exit Sub
  118.         
  119.         '---- add this Server to the Servers collection
  120.         On Error GoTo DuplicateKey
  121.         .ThisServer.Reconnect = chkReconnect.Value
  122.         Call Servers.Add(.ThisServer, .ThisServer.Alias)
  123.         
  124.         '---- object.Add(index, key, text, icon, smallIcon)
  125.         cmbServers.AddItem .ThisServer.Alias
  126.         cmbServers.ListIndex = cmbServers.ListCount - 1
  127.     End With
  128.     Exit Sub
  129. DuplicateKey:
  130.     MsgBox "The alias '" & Server.ThisServer.Alias & "' is already in your servers collection.", vbOKOnly + vbInformation, "Add Server Error"
  131. End Sub
  132. Private Sub cmdCancel_Click()
  133.     PressedOK = False
  134.     Unload Me
  135. End Sub
  136. Private Sub cmdOK_Click()
  137.     Dim ListIndex   As Integer
  138.     ListIndex = cmbServers.ListIndex
  139.     '---- if there is no selection just go away like the win explorer net mapping
  140.     If (ListIndex = lbNoSelection) Then
  141.         Set ThisServer = Nothing
  142.         PressedOK = False
  143.     Else
  144.         '---- create the HTTP Server which will be used by the Explorer
  145.         Set ThisServer = GetServer(cmbServers.List(ListIndex))
  146.         ThisServer.Reconnect = chkReconnect.Value
  147.         PressedOK = True
  148.     End If
  149.     Unload Me
  150. End Sub
  151. Private Sub cmdProperties_Click()
  152.     With Server
  153.         .Mode = ciProperties
  154.         .MyCaption = "HTTP Server Properties"
  155.         Set .ThisServer = GetServer(cmbServers.List(cmbServers.ListIndex))
  156.         .Show vbModal
  157.         If (Not .PressedOK) Then Exit Sub
  158.         
  159.         '---- modify the properties
  160.         .ThisServer.Reconnect = chkReconnect.Value
  161.         cmbServers.List(cmbServers.ListIndex) = .ThisServer.Alias
  162.     End With
  163. End Sub
  164. Private Sub cmdRemove_Click()
  165.     Dim ThisNode    As Node
  166.     Dim Alias       As String
  167.     On Error Resume Next '---- should never happen!
  168.     Alias = cmbServers.List(cmbServers.ListIndex)
  169.     Call Servers.Remove(Alias)
  170.     Call cmbServers.RemoveItem(cmbServers.ListIndex)
  171.     '---- remove item from explorer
  172.     Set ThisNode = ThisExplorer.Tree.Nodes.Item("Root.HTTPServers." & Alias)
  173.     Call ThisExplorer.RemoveNode(ThisNode)
  174.     On Error GoTo 0
  175.     cmdOK.Enabled = False
  176.     cmdRemove.Enabled = False
  177.     cmdProperties.Enabled = False
  178.     Set ThisNode = Nothing
  179. End Sub
  180. Private Sub Form_Initialize()
  181.     Dim i               As Integer
  182.     Dim PackedServer    As String
  183.     Set Servers = New Collection
  184.     '---- get the Servers from the registry
  185.     NumberServers = Val(GetSetting(App.ProductName, "ciHTTPServers", "ciNumberHTTPServers"))
  186.     For i = 1 To NumberServers
  187.         PackedServer = GetSetting(App.ProductName, "ciHTTPServers", "ciHTTPServer" & i)
  188.         Call UnpackServer(PackedServer)
  189.     Next
  190. End Sub
  191. Private Sub Form_Load()
  192.     Dim InstanceServer As HTTPServer
  193.     '---- list the servers
  194.     For Each InstanceServer In Servers
  195.         cmbServers.AddItem InstanceServer.Alias
  196.     Next
  197.     If (cmbServers.ListCount > 0) Then cmbServers.ListIndex = 0
  198.     Call CenterForm(Me)
  199. End Sub
  200. Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
  201.     If (Not (UnloadMode = vbFormCode)) Then
  202.         PressedOK = False
  203.     End If
  204. End Sub
  205. '-----------------------------------------------------
  206. '<Purpose> unpacks a delimited string into an
  207. ' HTTPServer class object
  208. '<Note> change this function to retrieve data from
  209. ' any repository
  210. '-----------------------------------------------------
  211. Private Function UnpackServer(PackedAddress As String) As Boolean
  212.     Dim CharPos         As Integer
  213.     Dim ThisServer      As New HTTPServer
  214.     Dim Alias           As String
  215.     On Error GoTo BadServer
  216.     CharPos = InStr(PackedAddress, regDelimiter)
  217.     Alias = left(PackedAddress, CharPos - 1)
  218.     ThisServer.Alias = Alias
  219.     PackedAddress = Mid(PackedAddress, CharPos + 1)
  220.     CharPos = InStr(PackedAddress, regDelimiter)
  221.     ThisServer.Reconnect = Val(left(PackedAddress, CharPos - 1))
  222.     PackedAddress = Mid(PackedAddress, CharPos + 1)
  223.     CharPos = InStr(PackedAddress, regDelimiter)
  224.     ThisServer.UseProxy = Val(left(PackedAddress, CharPos - 1))
  225.     PackedAddress = Mid(PackedAddress, CharPos + 1)
  226.     CharPos = InStr(PackedAddress, regDelimiter)
  227.     ThisServer.HostName = left(PackedAddress, CharPos - 1)
  228.     PackedAddress = Mid(PackedAddress, CharPos + 1)
  229.     CharPos = InStr(PackedAddress, regDelimiter)
  230.     ThisServer.ProxyName = left(PackedAddress, CharPos - 1)
  231.     PackedAddress = Mid(PackedAddress, CharPos + 1)
  232.     ThisServer.DefaultURL = PackedAddress
  233.     Call Servers.Add(ThisServer, Alias)
  234.     UnpackServer = True
  235. Cleanup:
  236.     Set ThisServer = Nothing
  237.     Exit Function
  238. BadServer:
  239.     MsgBox "An error occurred while unpacking an HTTP Server: " & Err.Description, vbOKOnly + vbInformation
  240.     UnpackServer = False
  241.     GoTo Cleanup
  242. End Function
  243. '------------------------------------------------------
  244. '<Purpose> returns an HTTPServer class object
  245. '------------------------------------------------------
  246. Public Function GetServer(Alias As String) As HTTPServer
  247.     On Error GoTo BadItem
  248.     Set GetServer = Servers.Item(Alias)
  249.     On Error GoTo 0
  250.     Exit Function
  251. BadItem:
  252.     Set GetServer = Nothing
  253.     On Error GoTo 0
  254. End Function
  255. '-----------------------------------------------------
  256. '<Purpose> packs a HTTPServer class object into a
  257. ' delimited string for storage in the registry
  258. '<Note> change this function to store data in any
  259. ' repository such as a relational DB
  260. '-----------------------------------------------------
  261. Private Function PackServer(ThisServer As HTTPServer) As String
  262.     Dim Temp        As String
  263.     Temp = ThisServer.Alias & regDelimiter
  264.     Temp = Temp & ThisServer.Reconnect & regDelimiter
  265.     Temp = Temp & ThisServer.UseProxy & regDelimiter
  266.     Temp = Temp & ThisServer.HostName & regDelimiter
  267.     Temp = Temp & ThisServer.ProxyName & regDelimiter
  268.     Temp = Temp & ThisServer.DefaultURL
  269.     PackServer = Temp
  270. End Function
  271. Private Sub Form_Terminate()
  272.     Dim i   As Integer
  273.     NumberServers = Servers.Count
  274.     For i = 1 To NumberServers
  275.         Call SaveSetting(App.ProductName, "ciHTTPServers", "ciHTTPServer" & i, PackServer(Servers(i)))
  276.     Next
  277.     'SaveSetting(appname, section, key, setting)
  278.     Call SaveSetting(App.ProductName, "ciHTTPServers", "ciNumberHTTPServers", NumberServers)
  279.     '---- explicitly clean up all object
  280.     Set Servers = Nothing
  281.     Set ThisServer = Nothing
  282. End Sub
  283. '------------------------------------------------------
  284. '<Purpose> turns off the "Reconnect" bit on a Server
  285. '------------------------------------------------------
  286. Public Sub Disconnect(Alias As String)
  287.     Dim ThisServer As HTTPServer
  288.     Set ThisServer = GetServer(Alias)
  289.     ThisServer.Reconnect = 0
  290.         
  291.     Set ThisServer = Nothing
  292. End Sub
  293.